home *** CD-ROM | disk | FTP | other *** search
/ The 640 MEG Shareware Studio 2 / The 640 Meg Shareware Studio CD-ROM Volume II (Data Express)(1993).ISO / prog / ach2tb.zip / FT_ACH2T.PRG < prev   
Text File  |  1992-05-01  |  34KB  |  798 lines
  1. /*
  2.  * File......: ACH2TB.PRG
  3.  * Author....: Steve Kolterman
  4.  * CIS ID....: 76320,37
  5.  * Date......: $Date:   15 Aug 1991 23:17:48  $
  6.  * Revision..: $Revision:   1.2  $
  7.  * Log file..: $Logfile:   E:/nanfor/src/ach2tb.prv  $
  8.  *
  9.  * This is an original work by Steve Kolterman and is placed in the
  10.  * public domain.                                                  
  11.  *
  12.  * Modification history:
  13.  * ---------------------
  14.  *
  15.  * $Log:   E:/nanfor/src/ach2tb.prv  $
  16.  *
  17.  *    Rev 1.2   15 Aug 1991 23:17:48   GLENN
  18.  * Last minute fix sent in by Steve Kolterman
  19.  *
  20.  *    Rev 1.1   15 Aug 1991 23:06:16   GLENN
  21.  * Forest Belt proofread/edited/cleaned up doc
  22.  *
  23.  *    Rev 1.0   14 Jun 1991 04:14:14   GLENN
  24.  * Initial revision.                                               
  25.  *
  26.  *
  27.  */
  28.  
  29. /*  $DOC$
  30.  *  $FUNCNAME$
  31.  *     FT_Ach2tb()
  32.  *  $ONELINER$
  33.  *     Replace ACHOICE() with a Tbrowse object and multiple features.
  34.  *  $SYNTAX$
  35.  *     FT_Ach2tb( <nToprow>,<nTopcol>[,<nBotrow>][,<nBotcol>],<aArrey>,     ;
  36.  *           [<cBoxtype>],[<cBoxcolor>],[<cBoxtitle>],[<nTitlePos>],        ;
  37.  *           [<cUselcolor>],[<cTitlecolor>],[<cBarcolor>],[<cHkcolor>],     ;
  38.  *           [<lShadow>],[<lExecute>],[<nMsgrow>],[<nMsgcol>],              ;
  39.  *           [<cMsg.color>],[cElevbar],[cEbarcolor],[<cEbarside>],          ;
  40.  *           [<cNoSelcolor>],[<cTagch>],[<nStartelem>],[<lRscreen>],        ;
  41.  *           [<nTimeout>],[<nTimeoutval>],[<cUserfunc>] )
  42.  *      --> nOption
  43.  *
  44.  *  $ARGUMENTS$
  45.  *
  46.  *  <nToprow>   is the top row of the box to be drawn.  Required.
  47.  *
  48.  *  <nTopcol>   is the top column of the box to be drawn.  Required.
  49.  *
  50.  *  <nBotrow>   is the bottom row of the box to be drawn.  The default is
  51.  *     <nToprow>+Len(<aArrey>)+1 or maxrow()-2, whichever is less.
  52.  *
  53.  *  <nBotcol>   is the bottom column of the box to be drawn.  The default
  54.  *     is <nTopcol>+width of the widest element in <aArrey>+2.
  55.  *
  56.  *  <aArrey>    is the arrey of options to present to the user.  Each
  57.  *     element can hold as many as five subelements, or as few as one.
  58.  *     Required.  Additional documentation below.
  59.  *
  60.  *  <cnBoxtype> is the type of box to draw.  Uses DispBox().  The
  61.  *     default is a double-line box.
  62.  *
  63.  *  <cBoxcolor> is the color with which to draw the box.  The default is
  64.  *     Setcolor().
  65.  *
  66.  *  <cBoxtitle> is title of the box drawn on <nToprow>.  The default is
  67.  *     no title.
  68.  *
  69.  *  <nTitlepos>  is the starting column position (to the right of
  70.  *     <nTopcol>) at which to draw <cBoxtitle>.  The default is 1.
  71.  *
  72.  *  <cUselcolor> is the color with which to draw unselected options.
  73.  *     The default is Setcolor().
  74.  *
  75.  *  <cTitlecolor> is the color with which to draw the box title.  The
  76.  *     default is yellow on red.
  77.  *
  78.  *  <cBarcolor>  is the color with which to draw the selection bar.
  79.  *     The default is yellow on black.
  80.  *
  81.  *  <cHkcolor>  is the default color with which to draw the hotkeys for
  82.  *     for each option.  This is used when no hotkey color is supplied
  83.  *     in <aArrey>.  The default is hiwhite on the current background
  84.  *     color.
  85.  *
  86.  *  <cShadow>   is a character string, either "L" or "R" (for left or
  87.  *     right) to designate the side of the box where a shadow will appear.
  88.  *     Leave this NIL to avoid drawing a shadow.  You might also leave
  89.  *     this NIL if you choose to use a .C or .ASM shadow function, which
  90.  *     is a good idea.  Shadoww(), included below, is flat-out SLOW.
  91.  *
  92.  *  <lExecute>  turn on/off execution of option when first letter is
  93.  *     pressed.  Rule:  setting in element 5 of each <aArrey> subarray
  94.  *     overrides <lexecute>.  If that element is left NIL, the <lexecute>
  95.  *     setting is used.  If <lexecute> is not passed and element 5 is NIL,
  96.  *     auto execution is turned ON.
  97.  *
  98.  *  <nMsgrow>  is the row on which to draw a message for each option.
  99.  *     The default is two rows below the bottom of the box.
  100.  *
  101.  *  <nMsgcol>  is the column at which to draw a message for each option.
  102.  *     The default is <nTopcol> +2.  To CENTER the message, pass "C".
  103.  *
  104.  *  <cMsgcolor>  is the default color with which to draw messages.  This
  105.  *     color is used when element 4 of each <aArrey> subarray is left NIL.
  106.  *     The default is Setcolor().
  107.  *
  108.  *  <cElevbar>  is the ASCII character to use as the elevator bar drawn
  109.  *     on the box.  Leave this NIL to draw no elevator bar.
  110.  *
  111.  *  <cEbarcolor>  is the color with which to draw the elevator bar.
  112.  *     This is ignored if <cElevbar> is NIL.
  113.  *
  114.  *  <cEbarside>  is a character string, either "L" or "R" (for left or
  115.  *     right) to designate the side of the box on which to draw the
  116.  *     elevator bar.  This is ignored if <cElevbar> is NIL.
  117.  *
  118.  *  <cNoselcolor>  is the color with which to draw unselectable options.
  119.  *     The default is white on black.
  120.  *
  121.  *  <cTagchar> is the ASCII character to use to draw tags that would
  122.  *     appear to the right of each option.  The default is *DIS*abled
  123.  *     tagging.  The default tag is "√" (chr(251)).
  124.  *
  125.  *  <nStartelem>  is the number of the option where the selection bar
  126.  *     will first be placed.  Leave this NIL to begin at option 1.
  127.  *
  128.  *  <lRestscrn>  is a logical to designate whether or not the screen
  129.  *     coordinates occupied by the box and/or shadow should be restored
  130.  *     before FT_Ach2tb() returns.  The default is .T.
  131.  *
  132.  *  <nTimeout>  is the number of seconds after which FT_ACH2TB() will
  133.  *     timeout and return to the function/proced. which called it.  The
  134.  *     default is 0.
  135.  *
  136.  *  <nTimeoutVal> is an optional alternative numeric value FT_ACH2TB() will
  137.  *     RETURN when/if it times out.  The default is the current element
  138.  *     number.
  139.  *
  140.  *  <bUserfunc>  is a code block containing a function call to be
  141.  *     executed after each key press.  You need to write just two formal
  142.  *     parameters to allow the run-time passing of the key pressed and the
  143.  *     current element number, e.g.:
  144.  *               { |key,num| Myfunc( key,num [,other params.] ) }
  145.  *     Unlimited extra parameters may be passed.  Of course, make certain
  146.  *     to also write 'receptors' for them in 'Myfunc()' itself...as in the
  147.  *     above example.  The default is NO user function.
  148.  *
  149.  *  $RETURNS$
  150.  *     the number of the selected option, or 0 if [Esc] is pressed.
  151.  *
  152.  *  $DESCRIPTION$
  153.  *     FT_Ach2tb() is a greatly enhanced, fully featured, and now mouse-
  154.  *     supported replacement for Achoice(), based on a Tbrowse object. 
  155.  *     Each element of <aArray> (the array you pass to it) is itself an
  156.  *     array.  Each element can solely composed of "Option" (below), but
  157.  *     may be composed as follows to take full advantage of the function's
  158.  *     features:
  159.  *
  160.  *         Option   ,     Message      ,HotKeyPos,HotKeyColor,Selectable
  161.  *     { "Utilities","System Utilities", 3       ,"+gr/b"    ,.T. }
  162.  *
  163.  *     All elements except for the first, the option itself, are optional.
  164.  *     IF 'Message' is NIL, no message is displayed.  'HotKeyPos' is the
  165.  *     position within 'Option' of the hotkey.  In the example above, the
  166.  *     hotkey for 'Utilities' is the first 'i', i.e., at position 3.  The
  167.  *     default is 1.  'HotKeyColor' is the color to use for the hotkey
  168.  *     display.  The default is hiwhite  on the current background color.
  169.  *     'Selectable' is a logical indicating whether or not that option can
  170.  *     be selected.  The default is .T.
  171.  *
  172.  *     The A_CHOICE() UDC in FT_ACH2T.CH makes using FT_ACH2TB() a breeze.
  173.  *     The myriad of parameters can be written in any order.  Only <nToprow>,
  174.  *     <nTopcol>, and <aArrey> are required.  See the example below.
  175.  *
  176.  *     There may be some confusion over 'unselected' and 'unselectable'
  177.  *     options.  The former refers to any option not currently covered
  178.  *     by the selection bar.  The latter refers to options you have
  179.  *     designated unselectable in subelement 5 of <aArray>, i.e., by
  180.  *     writing .F.
  181.  *
  182.  *     To enable tagging, pass any ASCII character as <cTagchar>.  To
  183.  *     tag/untag all options, press [SPACE].  To tag/untag individual
  184.  *     options, press [+] and [-] respectively.  On press of [+], browse
  185.  *     moves to the next element in the display.  To test for the tagged
  186.  *     status of an option, use the WAS_TAGGED() UDC in FT_ACH2T.CH. To
  187.  *     check the entire array for tags, use Aeval() in conjunction with
  188.  *     Was_Tagged() as in the example below.  When tagging is enabled, the
  189.  *     string "Tags" will be written across the bottom row of the box in
  190.  *     hiwhite on the current background color.
  191.  *
  192.  *     Because FT_ACH2TB() takes over the [SPACE],[+], and [-] keys, it saves
  193.  *     any SET KEY procedures you might have set them to, and restores same
  194.  *     on returning.  Any other procedures you might have SET KEYs to will
  195.  *     fly when FT_ACH2TB() is called...thanks to the Inkey() replacement,
  196.  *     SKINkey().
  197.  *
  198.  *     The piéce de resistance of FT_ACH2TB() is its ability to execute
  199.  *     a user function designed entirely by you.  It is called after each
  200.  *     keypress, and because it is completely open-ended, extends the
  201.  *     the reach of FT_ACH2TB() to the limits of Clipper.  See the docu-
  202.  *     mentation under <bUserfunc> above.
  203.  *
  204.  *
  205.  *     Test compile:  CLIPPER ft_ach2t /n/w/m/dFT_TEST
  206.  *     Test link   :  RTLINK FI ft_ach2t LIB nanfor /pll:base50
  207.  *
  208.  *
  209.  *     Mouse support
  210.  *     =============
  211.  *     Mouse support is provided via the Nanforum Toolkit FT_M* functions.
  212.  *     Most actions are tied to the left button.  The equivalent of pressing
  213.  *     [Esc] comes via the right button.  These left button clicks will
  214.  *     produce the designated actions:
  215.  *
  216.  *     Mouse cursor outside box                :  K_ENTER (select option)
  217.  *     Mouse cursor at box top left corner     :  browse:goTop()
  218.  *                         bottom left corner  :  browse:goBottom()
  219.  *                         top right corner    :  browse:pageUp()
  220.  *                         bottom right corner :  browse:pageDown()
  221.  *
  222.  *     Mouse cursor at option, tagging ENabled
  223.  *     --------------------------------------------
  224.  *     Selection bar moves to option, subsequent press to tag or untag.  Do
  225.  *     this for as many options as you want to tag/untag, then move mouse
  226.  *     cursor outside the box.  Press again to select.  Tagging overrides
  227.  *     <lExecute>, so with tagging on and <lExecute> .F., subsequent presses
  228.  *     while inside the box coordinates simply tag/untag.
  229.  *
  230.  *     Mouse cursor at option, tagging DISabled
  231.  *     ---------------------------------------------
  232.  *     IF <lExecute> is turned on, the option is immediately selected.  If
  233.  *     turned off, selection bar moves to option.  Press again to select.
  234.  *
  235.  *
  236.  *  $EXAMPLES$
  237.  *  nOpt := A_CHOICE( 7,9 ARRAY:t_array )   // the minimum
  238.  *
  239.  *  nOpt := A_CHOICE( 7,9 ARRAY:t_arrey USERFUNC:{|a,b| UserFunc(a,b,any1)};
  240.  *          BOXTYPE:B_SINGLE  BOXTITLE:title  SHADOW:"FT" TAGCHAR:chr(17);
  241.  *          REST_SCREEN:.F. AUTOEXEC:.F. MES_COLOR:MSG_COLOR ELEVBAR:"▒" ;
  242.  *          NOSELCOLOR:"bg/n" MES_COL:"C" )
  243.  *
  244.  *  Check only the RETURNed element for whether tagged:
  245.  *  IF( Was_Tagged(chr(17),t_arrey,nOpt), MoreProcessing(), )
  246.  *
  247.  *  Check entire 't_arrey':
  248.  *  Aeval( t_arrey,{|e,n| IF( Was_Tagged(chr(17),t_arrey,n ), ;
  249.  *                            MoreProcessing(t_arrey),NIL ) } )
  250.  *
  251.  *
  252.  *  $END$
  253.  */
  254.  
  255. #include "inkey.ch"
  256. #include "box.ch"
  257. #include "setcurs.ch"
  258. #include "ft_ach2t.ch"
  259.  
  260. #define KEY_ELEM         1
  261. #define BLK_ELEM         2
  262. #define AOPT             1
  263. #define AMSG             2
  264. #define AHOT             3
  265. #define ACLR             4
  266. #define ASEL             5
  267. #define TIMED_OUT        (lkey==999)
  268. #define HOTKEY_PRESS     (aelem > 0)
  269. #define METHOD_PRESS     (meth_num > 0 .and. meth_num <= 10)
  270. #define TAGS             (tagchar<>NIL)
  271. #define TAG_PRESS        (TAGS .and. (meth_num > 11))
  272. #define CONTINUING       (lkey <> K_ESC)
  273. #define OUTTA_HERE       EXIT
  274. #define ATTOP            (aindex==1)
  275. #define ATBOTT           (aindex==Len(arrey))
  276. #define USEL_COLOR       FG(Setcolor())+"/"+BG(Setcolor())
  277. #define BARCOLOR         if(iscolor(),"+gr/n","n/w")
  278. #define TITLECOLOR       if(iscolor(),"+gr/r","n/w")
  279. #define DEMOCOLOR        if(iscolor(),"+gr/b","+w/n")
  280. #define HK_COLOR         if(iscolor(),"w+/"+ BG(setcolor()),"w+/n")
  281. #define SELECTABLE       (if(len(arrey[aindex])==5 .and. arrey[aindex][5]<> NIL,;
  282.                          arrey[aindex][5],aexec))
  283. #define NOSELECT         (len(arrey[aindex])==5 .and. !(arrey[aindex][5]))
  284. #define DEFAULT_TAG      "√"
  285. #define UP_ARROW_POS     t+2,col4bar
  286. #define DN_ARROW_POS     b-2,col4bar
  287. #define UP_ARROW         if(top_elem > 1,chr(24),chr(25))
  288. #define DN_ARROW         if(bot_elem < num_elems,chr(25),chr(24))
  289. #define GOING_UP         (meth_num==10 .or. Ltrim(str(meth_num)) $ "2468")
  290. #define GOING_DOWN       (Ltrim(str(meth_num)) $ "13579")
  291. #define MESG_LEN         msg_data[1]
  292. #define MESG_COL         msg_data[2]
  293.  
  294. #xtranslate DISPMSG(<r>,<c>,<msg>[,<color>])           => ;
  295.             SetPos(<r>,<c>); DispOut(<msg>[,<color>])
  296. #translate  Clear([<t>,<l>,<b>,<r>])                   => ;
  297.             SCROLL([<t>,<l>,<b>,<r>])
  298. #command    DEFAULT <p> TO <val> [,<pn> TO <valn>]     => ;
  299.             <p> := IF( <p> == NIL, <val>, <p>) ;
  300.             [;<pn> := IF( <pn> == NIL, <valn>, <pn>)]
  301. #command    STABILIZE <o> => WHILE !<o>:stabilize(); END
  302.  
  303. #ifndef K_SPACEBAR
  304. #define K_SPACEBAR 32
  305. #endif
  306. #ifndef K_PLUS
  307. #define K_PLUS  43
  308. #define K_MINUS 45
  309. #endif
  310.  
  311. STATIC msg_data[2],aSaveArr:= {},oSaveobj
  312.  
  313. #ifdef FT_TEST
  314.  
  315. Function Test( passes )
  316.  
  317. //                 Item       Msg         HotKeyPos/HotkeyColor/Selectable
  318. LOCAL t_arrey:= { {"Larry"   ,"larry"    ,   ,"w+/b"          },;
  319.                   {"Dick"    ,"dick"     ,   ,"b/r"           },;
  320.                   {"Harry"   ,           ,  3,       ,.F.     },;
  321.                   {"Steve"   ,"steve"    ,  4,"g/bg"          },;
  322.                   {"Michelle","michelle"                      },;
  323.                   {"Barnabas",           ,  6,"gr+/w"         },;
  324.                   {"Fred"    ,"fred"                          },;
  325.                   {"Lisa"    ,"lisa"     ,  3,"n/r"           },;
  326.                   {"Eleanor" ,"eleanor"  ,  4,"bg/r"          },;
  327.                   {"Anthony" ,"anthony"  ,  3                 },;
  328.                   {"Charles" ,"charles"  ,   ,       ,.F.     },;
  329.                   {"Ollie"   ,"ollie"    ,  4,"r/w"           },;
  330.                   {"George"  ,           ,  5                 },;
  331.                   {"Paula"   ,"paula"                         },;
  332.                   {"Jack"    ,"jack"     ,  4                 },;
  333.                   {"Quinten" ,"quinten"                       },;
  334.                   {"Nancy"   ,"nancy"    ,  5,"w/n"           },;
  335.                   {"Warren"  ,"warren"   ,  1,"n/gr*"         } }
  336. LOCAL t_arrey2:= {{"Warren"  ,"warren"   ,   ,"w+/b"          },;
  337.                   {"Charles" ,"charles"                       },;
  338.                   {"Ollie"   ,"ollie"    ,  4,"r/w"           },;
  339.                   {"George"  ,           ,  5                 },;
  340.                   {"Paula"   ,"paula"    ,  3,"gr+/bg"        },;
  341.                   {"Harry"   ,           ,  3,       ,.F.     },;
  342.                   {"Michelle","michelle" ,   ,"gr+/gr"        },;
  343.                   {"Anthony" ,"anthony"  ,  2                 } }
  344.  
  345.  
  346. LOCAL title:= " SK Test ",retval,xx,o_color:= Setcolor( DEMOCOLOR ),o_blink
  347. LOCAL any1:= "User function called!",retval2
  348. LOCAL any2:= "User function2 called!"
  349.  
  350. DEFAULT passes to 3; passes:= IF(valtype(passes)=="C",val(passes),passes)
  351.  
  352. Clear()
  353.  
  354. o_blink:= SetBlink(.F.)
  355. FT_MReset() ; FT_MCursor(.T.)
  356. FOR xx:= 1 to passes
  357.   retval:= A_CHOICE( 7,9 ARRAY:t_arrey TITLEPOS:2 START_ELEM:retval ;
  358.            USERFUNC:{|a,b| UserFunc(a,b,any1,.F.,1,.T.)} ;
  359.            BOXTYPE:B_SINGLE  BOXTITLE:title  SHADOW:"FT" TAGCHAR:chr(17);
  360.            REST_SCREEN:.F. AUTOEXEC:.F. MES_COLOR:"+w/b" ELEVBAR:"▒" )
  361.   @ 1,0 say "Returned element "+Ltrim(str(retval))+" "
  362.   IF retval > 0
  363.      @ 2,0 say "That was "+IF( Was_Tagged(chr(17),t_arrey,retval) ,;
  364.                "a Tagged","an UNtagged")+"  element  "
  365.   END
  366.   @ 3,0 say "Press, Please "; inkey(0)
  367.   Clear()
  368.   retval2:= A_CHOICE( 5,9 ARRAY:t_arrey2  BOXTYPE:B_DOUBLE ELEVBAR:"░" ;
  369.             BOXTITLE:" SK Test2 " AUTOEXEC:.T. ELEVBAR_COLOR:"+w/r" ;
  370.             MES_COLOR:"+w/gr" USERFUNC:{|a,b| UserFunc(a,b,any2,.T.,3,.F.,4)} ;
  371.             REST_SCREEN:.F. ELEVBAR_SIDE:"R" TIME_OUT:4 MES_COL:"C" ;
  372.             START_ELEM:3 SHADOW:"L" BAR_COLOR:"+r/gr*" TIME_OUT VALUE:-999 )
  373.   @ 1,0 say "Returned element "+Ltrim(str(retval2))+" "
  374.   IF retval2 > 0
  375.     @ 2,0 say "That was "+IF( Was_Tagged(DEFAULT_TAG,t_arrey2,retval2) ,;
  376.                "a Tagged","an UNtagged")+"  element  "
  377.   END
  378.   @ 3,0 say "Press, Please "; inkey(0)
  379.   Clear()
  380.   
  381. NEXT
  382.  
  383. SetBlink(o_blink)
  384. QUIT
  385. RETURN NIL
  386.  
  387. #endif
  388.  
  389. FUNCTION FT_Ach2tb( t,l,b,r,arrey,boxtp,boxcolor,boxttl,ttlpos,uselcolor,;
  390.          ttlcolor,barcolor,hkcolor,shad,aexec,msg_row,msg_col,msg_color,;
  391.          ebar,ebarcolor,ebarside,noselcolor,tagchar,start_elem,r_screen,;
  392.          timeout,timeout_val,u_func )
  393.  
  394. LOCAL o_curs,lkey:= 0,meth_num:= 0,num_elems:= Len(arrey),ach_scrn,;
  395.       o_color,aelem:= 0,ex_req:= .F.,uf_cont:= .T.,top_elem,bot_elem,;
  396.       dm_color,o_blink,first_entry:= .T.,col4bar,didtag:=.F.,aindex, ;
  397.       a_chscrn,o_row:= Row(),o_col:= Col(),hotkeys[3],ab_methods,ab,;
  398.       lDecr:= .F.,lCansel:= .T.,dir:= "D"
  399.  
  400. DEFAULT boxtp TO B_DOUBLE,       ttlcolor TO TITLECOLOR,;
  401.         barcolor TO BARCOLOR,    r_screen TO .T. ,;
  402.         msg_col TO l+2,          noselcolor TO "w/n" ,;
  403.         msg_color TO USEL_COLOR, boxcolor TO Setcolor(),;
  404.         uselcolor TO USEL_COLOR, aexec TO .T. ,;
  405.         ebarcolor TO Setcolor(), ;
  406.         ebarside TO "L",         start_elem TO 1 ,;
  407.         timeout TO 0,            ttlpos TO 1
  408.  
  409. MESG_LEN:= 0; MESG_COL:= msg_col
  410. o_curs := SetCursor(SC_NONE)
  411. SR_keys( "S",hotkeys )
  412. IF b==NIL
  413.    b:= IF( (t+Len(arrey)+1) >= maxrow()-2,maxrow()-2,(t+Len(arrey)+1) )
  414. END
  415. DEFAULT msg_row TO b+2
  416. r:= PrepArray( arrey,l,r,TAGS,tagchar )
  417. ach_scrn := SaveScreen( t,l-2,b+2,r+2 )
  418.  
  419. IF arrey==aSaveArr
  420.    aindex:= oSaveobj:cargo[1]
  421.    ab:= oSaveObj ; ab:inValidate()
  422. ELSE
  423.    aindex:= 1
  424.    ab:= tbrowsenew( t+1,l+1,b-1,r-1 )
  425.    ab:addcolumn(tbcolumnnew("",{|| arrey[aindex][AOPT]} ))
  426.    ab:getcolumn(1):width   := (r-1 -l)
  427.    ab:gotopblock           := {|| aindex := 1}
  428.    ab:gobottomblock        := {|| aindex := num_elems}
  429.    ab:skipblock            := {|n| ASkip( n,@aindex,arrey )}
  430.    ab:colorspec            += ","+uselcolor+","+barcolor+","+noselcolor
  431.    ab:getcolumn(1):colorblock:= { || ;
  432.                    IF(NOSELECT,{8},{6}) ,;
  433.                    ab:getcolumn(1):defcolor:= IF(NOSELECT,{8,8},{6,7}) }
  434.    ab:cargo:= Array(1)
  435. ENDIF
  436.  
  437. aSaveArr:= AClone(arrey)
  438. lCanSel:= ( Ascan(arrey,{|e| Len(e)==ASEL .and. (e[ASEL]==NIL ;
  439.                              .or. e[ASEL]) }) ) == 0
  440. ab_methods:= Curs_Methods()
  441. PaintBox( t,l,b,r,boxtp,boxcolor,boxttl,ttlcolor,ttlpos,shad,TAGS )
  442. col4bar         := IF(upper(ebarside)=="L",l,r)
  443. IF( ebar <> NIL,ElevBar( t+1,col4bar,b,ebar,ebarcolor,ebarside ), )
  444.  
  445. ab:autolite(.F.)
  446.  
  447. WHILE CONTINUING
  448.  
  449.    DispBegin()
  450.    STABILIZE ab
  451.  
  452.    IF lCanSel         // at least one option is selectable.
  453.       WHILE NOSELECT
  454.          IF( dir=="U",IF(ATTOP,ab:goBottom(),ab:up()) ,;
  455.                       IF(ATBOTT,ab:goTop(),ab:down() ) )
  456.          STABILIZE ab
  457.       ENDDO
  458.    ENDIF
  459.  
  460.    top_elem:= 1+aindex-ab:rowPos; bot_elem:= top_elem+ab:rowcount-1
  461.  
  462.    IF first_entry .and. start_elem > 1
  463.       dir:= HotKeyPress( ab,arrey,start_elem,aindex,top_elem,bot_elem )
  464.       aindex:= start_elem
  465.       top_elem:= 1+aindex-ab:rowPos; bot_elem:= top_elem+ab:rowcount-1
  466.    END
  467.  
  468.    HotKeyColor( t,l,top_elem,arrey,ab:rowcount,hkcolor )
  469.  
  470.    DispMsgg( msg_row,msg_col,arrey,aindex,msg_color )
  471.    IF ebar <> NIL
  472.       DispMsg( UP_ARROW_POS,UP_ARROW,ebarcolor )
  473.       DispMsg( DN_ARROW_POS,DN_ARROW,ebarcolor )
  474.    END
  475.  
  476.    ab:hilite()
  477.    DispEnd()
  478.  
  479.    // idle mode...of sorts.
  480.    IF valtype(u_func)=="B"
  481.       uf_cont:= Eval( u_func,lkey,IF(didtag .and. lDecr,aindex-1,aindex) )
  482.    ENDIF
  483.  
  484.    IF ex_req .or. !uf_cont; OUTTA_HERE; ELSE; lkey:= 0; END
  485.  
  486.    **************************************************************************
  487.    lkey     := SKInkey( timeout,ab,arrey,aindex,t,l,b,r,TAGS,tagchar,aexec )
  488.    **************************************************************************
  489.  
  490.    meth_num := Ascan( ab_methods, {|e| lkey == e})
  491.    aelem    := Ascan( arrey,{|e| IF(Len(e) >= AHOT .and. e[AHOT]<>NIL,;
  492.                       upper(chr(lkey)) == upper(subs(Ltrim(e[AOPT]),e[AHOT],1)) ,;
  493.                       upper(chr(lkey)) == upper(left(Ltrim(e[AOPT]),1)) ) } )
  494.  
  495.    DO CASE
  496.    CASE TIMED_OUT
  497.       ex_req:= .T. ; timeout_val:= IF(timeout_val==NIL,aindex,timeout_val)
  498.    CASE HOTKEY_PRESS
  499.       dir   := HotKeyPress(ab,arrey,aelem,aindex,top_elem,bot_elem)
  500.       ex_req:= SELECTABLE; aindex:= aelem
  501.    CASE METHOD_PRESS .or. lkey==K_ENTER
  502.       ExecKey( lKey,ab,ATTOP,ATBOTT )
  503.       ex_req:= ((lkey==K_ENTER) .and. !NOSELECT)
  504.    CASE TAG_PRESS
  505.       didtag:= TagPress( ab,arrey,aindex,lkey,tagchar,@lDecr )
  506.    ENDCASE
  507.  
  508.    dir   := IF(GOING_UP,"U",IF(GOING_DOWN,"D",dir) )
  509.    ex_req:= IF( lkey==0,.T.,ex_req ) ; first_entry:= .F.
  510.  
  511. ENDDO
  512.  
  513. ab:cargo[1]:= aindex ; oSaveobj:= ab
  514. Aeval( arrey,{|e| e[AOPT]:= Ltrim(e[AOPT]) } )
  515. SetPos(o_row,o_col); SetCursor(o_curs)
  516. IF( r_screen,RestScreen( t,l-2,b+2,r+2,ach_scrn ), )
  517. SR_keys( "R",hotkeys )
  518. RETURN IF( lkey==K_ESC, 0, IF(TIMED_OUT,timeout_val,aindex) )
  519. ************************************************************************
  520. STATIC FUNCTION Askip(num_elems, aindex, arrey)
  521. LOCAL save_aindex := aindex
  522. aindex:= IF( aindex+num_elems > Len(arrey), Len(arrey),;
  523.          IF( aindex+num_elems < 1, 1, aindex+num_elems ))
  524. RETURN (aindex - save_aindex)
  525. *************************************************************************
  526. STATIC FUNCTION HotKeyPress( ab,arrey,elem,aindex,top_elem,bot_elem )
  527. LOCAL cur_elem:= aindex,new_elem:= elem,dest,dir:= "D"
  528.  
  529. WHILE cur_elem < new_elem            // descending
  530.    dest:= MIN( new_elem,bot_elem ) ; dir:= "D"
  531.    WHILE cur_elem < dest; ab:down(); cur_elem++; END    // speeding
  532.    STABILIZE ab
  533.    WHILE cur_elem < new_elem ; ab:down() ; STABILIZE ab; cur_elem++; END
  534. END
  535. WHILE cur_elem > new_elem            // ascending
  536.    dest:= MAX( new_elem,top_elem ) ; dir:= "U"
  537.    WHILE cur_elem > dest; ab:up(); cur_elem--; END      // speeding
  538.    STABILIZE ab
  539.    WHILE cur_elem > new_elem ; ab:up()   ; STABILIZE ab; cur_elem--; END
  540. END
  541.  
  542. RETURN dir
  543. *************************************************************************
  544. STATIC FUNCTION DispMsgg( r,c,arrey,pos,msg_color )
  545. LOCAL dm_color
  546. IF( MESG_LEN > 0, Clear( r,MESG_COL,r,MESG_COL+MESG_LEN ), )
  547.  
  548. IF Len(arrey[pos]) >= AMSG .and. arrey[pos][AMSG] <> NIL  // if msg. to display
  549.    dm_color:= IF(Len(arrey[pos]) >= ACLR .and. arrey[pos][ACLR]<>NIL,;
  550.               arrey[pos][ACLR],msg_color)
  551.    IF valtype(c)== "C" .and. c=="C"  // indicating Centering
  552.       c:= Int( (maxcol()/2) - (Len(arrey[pos][AMSG])/2) )
  553.    ENDIF
  554.    DispMsg( r,c,arrey[pos][AMSG],dm_color )
  555.    MESG_LEN:= Len(arrey[pos][AMSG])
  556.    MESG_COL:= c
  557. END
  558. RETURN NIL
  559. *************************************************************************
  560. /*
  561. this is here for test purposes.  the default is NO user func.
  562. */
  563. #ifdef FT_TEST
  564.  
  565. FUNCTION UserFunc( key,elem_num,anything,aexec,st_elem,tag,tmout )
  566. LOCAL ret_val:= .T.
  567. DEFAULT tmout TO 0
  568. @ 09,45 say "            LASTKEY: "+Ltrim(str(key))+"  "
  569. @ 10,45 say "CURRENT ELEMENT NUM: "+Ltrim(str(elem_num))+"  "
  570. @ 11,45 say "  AUTO-EXECUTION IS: "+if(aexec,"ON ","OFF")
  571. @ 12,45 say "STARTING AT ELEMENT: "+ltrim(str(st_elem))
  572. @ 13,45 say "         TAGGING IS: "+if(tag,"ENABLED ","DISABLED")
  573. @ 14,45 say "            TIMEOUT: "+if(tmout >0,ltrim(str(tmout))+" secs.  ",;
  574.                                     "INACTIVE      ")
  575. IF anything <> NIL; @ 16,45 say anything; END
  576.  
  577. /*
  578. return .F. if you want to leave FT_ACH2TB() after whatever
  579. processing you do here.
  580. */
  581.  
  582. RETURN (ret_val)
  583. #endif
  584.  
  585. **************************************************************************
  586. #define ELEM2USE    arrey[top_elem+i]
  587. #define CANT_SELECT (len(ELEM2USE)==5 .and. !ELEM2USE[ASEL])
  588.  
  589. STATIC FUNCTION HotKeyColor( t,l,top_elem,arrey,rowcount,hkcolor )
  590. LOCAL i:= 0,color2use,col2use,charpos,xx
  591. FOR xx:= 1 TO rowcount
  592.     color2use:= IF( Len(ELEM2USE) >=ACLR .and. ELEM2USE[ACLR]<>NIL,;
  593.                 ELEM2USE[ACLR], IF(hkcolor<>NIL,hkcolor,HK_COLOR) )
  594.     col2use:=   IF(len(ELEM2USE) >=AHOT .and. ELEM2USE[AHOT]<>NIL,;
  595.                 l+1+ELEM2USE[AHOT],l+2)
  596.     charpos:=   IF(len(ELEM2USE) >=AHOT .and. ELEM2USE[AHOT]<>NIL,;
  597.                 ELEM2USE[AHOT],1 )
  598.     IF !CANT_SELECT
  599.        SetPos( t+xx,col2use )
  600.        DispOut( SUBS(Ltrim(ELEM2USE[AOPT]),charpos,1),color2use )
  601.     ENDIF
  602.     i++
  603. NEXT
  604. RETURN NIL
  605. ****************************************************************************
  606. STATIC FUNCTION Curs_Methods()
  607. RETURN (  { ;
  608.           K_DOWN,     ;
  609.           K_UP,       ;
  610.           K_PGDN,     ;
  611.           K_PGUP,     ;
  612.           K_CTRL_PGDN,;
  613.           K_CTRL_PGUP,;
  614.           K_CTRL_END ,;
  615.           K_CTRL_HOME,;
  616.           K_END,      ;
  617.           K_HOME,     ;
  618.           K_ENTER,    ;
  619.           K_SPACEBAR, ;
  620.           K_PLUS,     ;
  621.           K_MINUS } )
  622. ****************************************************************************
  623. STATIC FUNCTION ExecKey( lKey,ab,lTop,lBot )
  624. DO CASE
  625.    CASE lKey==K_DOWN       ; IF(lBot,ab:goTop(),ab:down())
  626.    CASE lKey==K_UP         ; IF(lTop,ab:goBottom(),ab:up())
  627.    CASE lKey==K_PGDN       ; IF(lBot,ab:goTop(),ab:pagedown())
  628.    CASE lKey==K_PGUP       ; IF(lTop,ab:goBottom(),ab:pageup())
  629.    CASE lKey==K_CTRL_PGDN .or. lKey==K_CTRL_END .or. lKey==K_END
  630.                              IF(lBot,ab:goTop(),ab:gobottom())
  631.    CASE lKey==K_CTRL_PGUP .or. lKey==K_CTRL_HOME .or. lKey==K_HOME
  632.                              IF(lTop,ab:goBottom(),ab:goTop())
  633. ENDCASE
  634. RETURN NIL
  635. ****************************************************************************
  636. STATIC FUNCTION ElevBar( t,col4bar,b,ebar,bcolor )
  637. LOCAL c:= 0
  638. Aeval( Array(b-t),{ |e,n| SetPos(t+c,col4bar),DispOut(ebar,bcolor),c++ })
  639. RETURN NIL
  640. ****************************************************************************
  641. #define TARGET   arrey[pos][AOPT]
  642. #define TAGGED   (tagchar $TARGET)
  643. #define AEV_TARG arrey[n][AOPT]
  644. #define AEV_TAGD (tagchar $AEV_TARG)
  645.  
  646. STATIC FUNCTION TagPress( ab,arrey,pos,lkey,tagchar,lDecr )
  647. LOCAL didtag:= .F.
  648.  
  649. IF (lkey==K_PLUS .and. !TAGGED) .or. (lkey==K_MINUS .and. TAGGED)
  650.    TARGET:= IF( (lkey==K_PLUS .and. !TAGGED) ,;
  651.                 Left(TARGET,Len(TARGET)-1)+tagchar ,;
  652.             IF( (lkey==K_MINUS .and. TAGGED) ,;
  653.                 Strtran(TARGET,tagchar," ")  ,;
  654.                 TARGET ))
  655.    ab:refreshcurrent(); didtag:= .T.
  656.    IF lKey==K_PLUS .and. TAGGED
  657.       ab:down() ; lDecr:= (pos < Len(arrey))
  658.    ENDIF
  659. ENDIF
  660. IF lkey==K_SPACEBAR
  661.    IF !(Ascan(arrey,{|e| tagchar $ e[AOPT] }) > 0)
  662.       Aeval(arrey,{|e,n| AEV_TARG:= Left(AEV_TARG,Len(AEV_TARG)-1)+tagchar })
  663.    ELSE
  664.       Aeval(arrey,{|e,n| AEV_TARG:= Strtran(AEV_TARG,tagchar," ") })
  665.    END
  666.    ab:refreshall() ; didtag:= .T.
  667. ENDIF
  668. RETURN (didtag)
  669. ****************************************************************************
  670. #translate CenterB( <b>,<l>,<r>,<msg>[,<color>] ) => ;
  671.            SetPos(<b>,(<l>+Int((<r>-<l> -Len(<msg>))/2) ) ) ;;
  672.            DispOut(<msg>[,<color>])
  673.  
  674. STATIC FUNCTION PaintBox( t,l,b,r,boxtp,boxcolor,boxttl,ttlcolor,ttlpos,shad,tags )
  675.  IF shad <> NIL
  676.     IF( shad=="FT",FT_Shadow( t,l+1,b,r ), )
  677.     IF( shad $"LR",Shadoww( t,l,b,r,upper(shad) ), )
  678.  ENDIF
  679.  DispBox( t,l,b,r,boxtp,boxcolor )
  680.  IF boxttl <> NIL; DispMsg( t,(l+ttlpos),boxttl,ttlcolor ); END
  681.  IF tags .and. (r-l) >= Len("tags")
  682.     CenterB( b,l,r,"Tags","+w/"+BG(boxcolor) )
  683.  END
  684. RETURN NIL
  685. ****************************************************************************
  686. STATIC FUNCTION PrepArray( arrey,l,r,tags,tagchar )
  687. Aeval( arrey,{|e| e[AOPT]:= " " +AllTrim( ;
  688.                   IF(tags,StrTran(e[AOPT],tagchar),e[AOPT]) ) } )
  689. IF r==NIL; r:= 0
  690.    Aeval( arrey,{|e| r:= MAX( r,Len(e[AOPT]) ) })
  691.    r+= IF( !tags,(l+2),(l+3) )
  692. ENDIF
  693. IF( tags,Aeval( arrey,{|e| e[AOPT]:= Padr(e[AOPT],r-l-1) }), )
  694. RETURN (r)
  695. *****************************************************************************
  696. STATIC FUNCTION BG( color )
  697. LOCAL startpos:= AT("/",color)+1
  698. LOCAL endpos:= IF( "," $ color,AT(",",color),len(color)+1 )
  699. RETURN upper(subs( color,startpos,(endpos-startpos) ))
  700. *****************************************************************************
  701. STATIC FUNCTION FG( color )
  702. RETURN upper(subs( color,1,AT("/",color)-1 ))
  703. *****************************************************************************
  704. STATIC FUNCTION SKInkey( nSecs,ab,arrey,aindex,t,l,b,r,tags,tagchar,aexec )
  705. LOCAL bBlock,nKey:= 0,lLooping:= .T.
  706. WHILE lLooping
  707.     nKey:= Mouser( nSecs,ab,arrey,aindex,t,l,b,r,tags,tagchar,aexec )
  708.     lLooping:= .F.
  709.     IF nKey==0 .and. Nextkey() <> 0
  710.        FT_MShowcrs()
  711.        nKey:= Inkey( nSecs )
  712.        IF ( bBlock := Setkey(nKey) ) <> NIL
  713.           Eval( bBlock, Procname(1), Procline(1), Readvar() )
  714.        ELSE; lLooping:= .F.
  715.        ENDIF
  716.     ENDIF
  717. ENDDO
  718. RETURN (nKey)
  719. ****************************************************************************
  720. STATIC FUNCTION Mouser( nSecs,ab,arrey,aindex,t,l,b,r,tags,tagchar,aexec )
  721. LOCAL nR:= 0,nCurrow,nNumpos:= 0,nKey:= 0,cur_elem,pos,lLooping:= .T.,;
  722.       lDown:= .F.,nTime:= Seconds()
  723.    // while no button or key pressed.
  724.  
  725.    WHILE lLooping .and. Nextkey()==0
  726.       FT_MShowcrs()
  727.       IF nSecs > 0 .and. (Seconds() >= nTime+nSecs)
  728.          nKey:= 999 ; lLooping:= .F.
  729.       ELSEIF FT_Mbutrel(1)==2               // right button == ESC
  730.          nKey:= K_ESC ; lLooping:= .F.
  731.       ELSEIF FT_Mbutrel(0)==1           // left button pressed
  732.          DO CASE
  733.            CASE FT_Minregion( t,l,t,l ) .or. FT_Minregion( b,l,b,l )
  734.                 nKey:= IF( FT_Minregion( t,l,t,l ),K_CTRL_PGUP,;  // upper left
  735.                        IF( FT_Minregion( b,l,b,l ),K_CTRL_PGDN,nKey) ) // lower left
  736.                 lLooping:= .F.
  737.            CASE FT_Minregion( t,r,t,r ) .or. FT_Minregion( b,r,b,r )
  738.                 nKey:= IF( FT_Minregion( t,r,t,r ),K_PGUP, ;      //upper right corner
  739.                        IF( FT_Minregion( b,r,b,r ),K_PGDN,nKey )) //lower left corner
  740.                 lLooping:= .F.
  741.            CASE !(FT_Minregion(t,l,b,r))
  742.                 nKey:= K_ENTER ; lLooping:= .F.
  743.            OTHERWISE
  744.                 IF FT_MInregion(t+1,l+1,b-1,r-1)
  745.                    // mouse row.
  746.                    nR:= FT_MgetX()
  747.                    // what row does current elem occupy?
  748.                    nCurrow:= ab:nTop+ab:rowPos-1
  749.                    // difference between this and nR is number of positions to move.
  750.                    nNumpos:= IF( nR==nCurrow,0,ABS(nR-nCurrow))
  751.                    cur_elem:= arrey[ aindex+ IF( nR > nCurrow,nNumpos,-nNumpos ) ]
  752.                    IF nNumpos==0
  753.                       nKey:= IF(tags, ;
  754.                              IF(tagchar $ cur_elem[1],K_MINUS,K_PLUS),;
  755.                                 K_ENTER)
  756.                       lLooping:= .F.
  757.                    ENDIF
  758.                    IF nNumpos > 0
  759.                       // if no hotkeys, we'll move ourselves and return -1.
  760.                       // -1 indicating no handling in the main loop.
  761.                       lDown:= (nR > nCurrow)
  762.                       WHILE nR > nCurrow ; ab:down(); nCurrow++ ; ENDDO
  763.                       WHILE nR < nCurrow ; ab:up()  ; nCurrow-- ; ENDDO
  764.                       // if element is unselectable, move one above or below.
  765.                       IF Len(cur_elem)==ASEL .and. cur_elem[ASEL]<>NIL .and. ;
  766.                          !cur_elem[ASEL]
  767.                          IF(lDown,ab:down(),ab:up())
  768.                       ENDIF
  769.                       nKey:= IF(tags .or. !aexec, -1, K_ENTER)
  770.                       lLooping:= .F.
  771.                    ENDIF
  772.                 ENDIF
  773.          ENDCASE
  774.       ENDIF
  775.    ENDDO
  776. FT_MHidecrs()
  777. RETURN (nKey)
  778. ****************************************************************************
  779. STATIC FUNCTION SR_Keys( action,hotkeys )
  780. IF action=="S"
  781.    hotkeys[1] := Setkey(K_SPACEBAR) ; Setkey(K_SPACEBAR,NIL)
  782.    hotkeys[2] := Setkey(K_PLUS)     ; Setkey(K_PLUS,NIL)
  783.    hotkeys[3] := Setkey(K_MINUS)    ; Setkey(K_MINUS,NIL)
  784. ELSEIF action=="R"
  785.    Setkey(K_SPACEBAR,hotkeys[1])
  786.    Setkey(K_PLUS,hotkeys[2])
  787.    Setkey(K_MINUS,hotkeys[3])
  788. END
  789. RETURN NIL
  790. ****************************************************************************
  791. STATIC FUNCTION Shadoww( t,l,b,r,side )
  792. LOCAL bx
  793. DEFAULT side TO "R"
  794. l+= IF(side=="R",2,-2); r+= IF(side=="R",2,-2)
  795. bx:= SaveScreen( ++t,l,++b,r )
  796. RestScreen( t,l,b,r,Transf( bx,Replic("x"+chr(8),len(bx)/2) ) )
  797. RETURN NIL
  798.